home *** CD-ROM | disk | FTP | other *** search
/ Mac Magazin/MacEasy 2 / Mac Magazin and MacEasy Magazine CD - Issue 02.iso / Sharewarebibliothek / Applikationen / Alpha.5.81 folder / Tcl / SystemCode / misc.tcl < prev    next >
Text File  |  1994-07-28  |  14KB  |  578 lines
  1. #===========================================================================
  2. # Information about a selection or window.
  3. #===========================================================================
  4. proc wordCount {} {
  5.     if {[set chars [expr {[selEnd] - [getPos]}]]} {
  6.         set lines [expr {[lindex [posToRowCol [selEnd]] 0] - [lindex [posToRowCol [getPos]] 0]}]
  7.         set text [getSelect]
  8.     } else {
  9.         set chars [maxPos]
  10.         set lines [lindex [posToRowCol $chars] 0]
  11.         set text [getText 0 [maxPos]]
  12.     }
  13.     if {[regsub -all {[!=;.,\(\#\=\):\{\"\}]} $text " " ret]} {
  14.         set words [llength $ret]
  15.     } else {
  16.         set words [llength $text]
  17.     }
  18.     alertnote [format "%d chars, %d words, %d lines" $chars $words $lines]
  19. }
  20.  
  21. proc matchingLines {} {
  22.     if [catch {prompt "Regular expression:" ""} reg] return
  23.     if {![string length $reg]} return
  24.     set reg ^.*$reg.*$
  25.     set pos [getPos]
  26.     set matches 0
  27.     while {![catch {search -f 1 -r 1 -m 0 -i 1 $reg $pos} mtch]} {
  28.         append lines "\r" [format "%4d: " [lindex [posToRowCol [lindex $mtch 0]] 0]] [eval getText $mtch]
  29.         set pos [lindex $mtch 1]
  30.         incr matches
  31.     }
  32.     new
  33.     insertText [format "%d matching lines\r-----" $matches] $lines "\r"
  34. }
  35.  
  36.  
  37. #=============================================================================
  38. # Random functions.
  39. #=============================================================================
  40.  
  41. #***********************************************************************
  42. #                                                                      *
  43. #   Comment box and uncomment box courtesy of Igor Mikolic-Torreira.   *
  44. #                                                                      *
  45. #**********************************************************************/
  46.  
  47. proc commentBox {} {
  48.  
  49. # Preliminaries
  50.  
  51.     if {[getPos] == [selEnd]} {
  52.         alertnote "Must select region to be commented."
  53.         return
  54.     }
  55.     global lastMode
  56.     watchCursor
  57.     
  58. # Set what the comment block will look like
  59.  
  60.     case $lastMode in {
  61.         "Text" {
  62.             set begComment "!"
  63.             set begComLen 1
  64.             set endComment "!"
  65.             set endComLen 1
  66.             set fillChar "!"
  67.             set spaceOffset 3
  68.         }
  69.         "Fort" {
  70.             set begComment "C"
  71.             set begComLen 1
  72.             set endComment "C"
  73.             set endComLen 1
  74.             set fillChar "C"
  75.             set spaceOffset 3
  76.         }
  77.         "Tcl" {
  78.             set begComment "#"
  79.             set begComLen 1
  80.             set endComment "#"
  81.             set endComLen 1
  82.             set fillChar "#"
  83.             set spaceOffset 3
  84.         }
  85.         "C" {
  86.             set begComment "/*"
  87.             set begComLen 2
  88.             set endComment "*/"
  89.             set endComLen 2
  90.             set fillChar "*"
  91.             set spaceOffset 3
  92.         }
  93.         "C++" {
  94.             set begComment "/*"
  95.             set begComLen 2
  96.             set endComment "*/"
  97.             set endComLen 2
  98.             set fillChar "*"
  99.             set spaceOffset 3
  100.         }
  101.         default {
  102.             alertnote "I don't know what comments should look like in this mode.  Sorry."
  103.             return
  104.         }
  105.     }
  106.     set aSpace " "
  107.  
  108. # First make sure we grab a full block of lines and adjust highlight
  109.  
  110.     set start [getPos]
  111.     set start [lineStart $start]
  112.     set end [selEnd]
  113.     set end [nextLineStart [expr $end-1]]
  114.     select $start $end
  115.  
  116. # Now get rid of any tabs
  117.     
  118.     if { $end < [maxPos] } then {
  119.         createTMark stopComment [expr $end+1]
  120.         tabsToSpaces
  121.         gotoTMark stopComment
  122.         set end [expr [getPos]-1]
  123.         removeTMark stopComment
  124.     } else {
  125.         tabsToSpaces
  126.         set end [maxPos]
  127.     }
  128.     select $start $end
  129.     set text [getText $start $end]
  130.     
  131. # Next turn it into a list of lines--possibly drop an empty 'last line'
  132.  
  133.     set lineList [split $text "\r"]
  134.     set emptyLine [lsearch $lineList {}]
  135.     if { $emptyLine != -1 } then {
  136.         set numLines [llength $lineList]
  137.         set lineList [lrange $lineList 0 [expr $numLines-2]]
  138.     }
  139.     set numLines [llength $lineList]
  140.     
  141. # Find the longest line length and determine the new line length
  142.  
  143.     set maxLength 0
  144.     foreach thisLine $lineList {
  145.         set thisLength [string length $thisLine]
  146.         if { $thisLength > $maxLength } then { 
  147.             set maxLength $thisLength 
  148.         }
  149.     }
  150.     set newLength [expr {$maxLength + 2 + 2*$spaceOffset}]
  151.     
  152. # Now create the top & bottom bars and a blank line
  153.  
  154.     set topBar $begComment
  155.     for { set i 0 } { $i < [expr {$newLength - $begComLen}] } { incr i } {
  156.         set topBar $topBar$fillChar
  157.     }
  158.     set botBar ""
  159.     for { set i 0 } { $i < [expr {$newLength - $endComLen}] } { incr i } {
  160.         set botBar $botBar$fillChar
  161.     }
  162.     set botBar $botBar$endComment
  163.     set blankLine $fillChar
  164.     for { set i 0 } { $i < [expr {$newLength - 2}] } { incr i } {
  165.         set blankLine $blankLine$aSpace
  166.     }
  167.     set blankLine $blankLine$fillChar
  168.     
  169. # For each line add stuff on left and spaces and stuff on right for box sides
  170. # and concatenate everything into 'text'.  Start with topBar; end with botBar
  171.  
  172.     set text $topBar\r$blankLine\r
  173.     
  174.     set frontStuff $fillChar
  175.     set backStuff $fillChar
  176.     for { set i 0 } { $i < $spaceOffset } { incr i } {
  177.         set frontStuff $frontStuff$aSpace  
  178.         set backStuff $aSpace$backStuff
  179.     }
  180.     set backStuffLen [string length $backStuff]
  181.     
  182.     for { set i 0 } { $i < $numLines } { incr i } {
  183.         set thisLine [lindex $lineList $i ]
  184.         set thisLine $frontStuff$thisLine
  185.         set thisLength [string length $thisLine]
  186.         set howMuchPad [expr {$newLength - $thisLength - $backStuffLen}]
  187.         for { set j 0 } { $j < $howMuchPad } { incr j } {
  188.             set thisLine $thisLine$aSpace 
  189.         }
  190.         set thisLine $thisLine$backStuff
  191.         set text $text$thisLine\r
  192.     }
  193.     
  194.     set text $text$blankLine\r$botBar\r
  195.     
  196. # Now replace the old stuff, turn spaces to tabs, and highlight
  197.  
  198.     replaceText    $start $end    $text
  199.     set end [expr {$start+[string length $text]}]
  200.     createTMark stopComment [expr $end+1]
  201.     select $start $end
  202.     spacesToTabs
  203.     gotoTMark stopComment
  204.     set end [expr [getPos]-1]
  205.     removeTMark stopComment
  206.     select $start $end
  207. }
  208.  
  209.  
  210.  
  211. proc uncommentBox {} {
  212.  
  213. # Preliminaries
  214.  
  215.     if {[getPos] == [selEnd]} {
  216.         alertnote "Must select region to be uncommented."
  217.         return
  218.     }
  219.     global lastMode
  220.     watchCursor
  221.     
  222. # Set what the comment block will look like
  223.  
  224.     case $lastMode in {
  225.         "Text" {
  226.             set begComment "!"
  227.             set begComLen 1
  228.             set endComment "!"
  229.             set endComLen 1
  230.             set fillChar "!"
  231.             set spaceOffset 3
  232.         }
  233.         "Fort" {
  234.             set begComment "C"
  235.             set begComLen 1
  236.             set endComment "C"
  237.             set endComLen 1
  238.             set fillChar "C"
  239.             set spaceOffset 3
  240.         }
  241.         "Tcl" {
  242.             set begComment "#"
  243.             set begComLen 1
  244.             set endComment "#"
  245.             set endComLen 1
  246.             set fillChar "#"
  247.             set spaceOffset 3
  248.         }
  249.         "C" {
  250.             set begComment "/*"
  251.             set begComLen 2
  252.             set endComment "*/"
  253.             set endComLen 2
  254.             set fillChar "*"
  255.             set spaceOffset 3
  256.         }
  257.         "C++" {
  258.             set begComment "/*"
  259.             set begComLen 2
  260.             set endComment "*/"
  261.             set endComLen 2
  262.             set fillChar "*"
  263.             set spaceOffset 3
  264.         }
  265.         default {
  266.             alertnote "I don't know what comments should look like in this mode.  Sorry."
  267.             return
  268.         }
  269.     }
  270.     set aSpace " "
  271.     set aTab \t
  272.  
  273. # First make sure we grab a full block of lines
  274.  
  275.     set start [getPos]
  276.     set start [lineStart $start]
  277.     set end [selEnd]
  278.     set end [nextLineStart [expr $end-1]]
  279.     set text [getText $start $end]
  280.  
  281. # Make sure we're at the start and end of the box
  282.  
  283.     set startOK [string first $begComment $text]
  284.     set endOK [string last $endComment $text]
  285.     set textLength [string length $text]
  286.     if { $startOK != 0 || ($endOK != [expr {$textLength-$endComLen-1}] || $endOK == -1) } then {
  287.         alertnote "You must highlight the entire comment box, including the borders."
  288.         return
  289.     }
  290.     
  291. # Now get rid of any tabs
  292.     
  293.     if { $end < [maxPos] } then {
  294.         createTMark stopComment [expr $end+1]
  295.         tabsToSpaces
  296.         gotoTMark stopComment
  297.         set end [expr [getPos]-1]
  298.         removeTMark stopComment
  299.     } else {
  300.         tabsToSpaces
  301.         set end [maxPos]
  302.     }
  303.     select $start $end
  304.     set text [getText $start $end]
  305.     
  306. # Next turn it into a list of lines--possibly drop an empty 'last line'
  307.  
  308.     set lineList [split $text "\r"]
  309.     set emptyLine [lsearch $lineList {}]
  310.     if { $emptyLine != -1 } then {
  311.         set numLines [llength $lineList]
  312.         set lineList [lrange $lineList 0 [expr $numLines-2]]
  313.     }
  314.     set numLines [llength $lineList]
  315.     
  316. # Delete the first and last lines, recompute number of lines
  317.  
  318.     set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  319.     set lineList [lreplace $lineList 0 0 ]
  320.     set numLines [llength $lineList]
  321.     
  322. # Eliminate 2nd and 2nd-to-last lines if they are empty
  323.  
  324.     set eliminate $fillChar$aSpace$aTab
  325.     set thisLine [lindex $lineList [expr $numLines-1]]
  326.     set thisLine [string trim $thisLine $eliminate]
  327.     if { [string length $thisLine] == 0 } then {
  328.         set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  329.     }
  330.     set thisLine [lindex $lineList 0]
  331.     set thisLine [string trim $thisLine $eliminate]
  332.     if { [string length $thisLine] == 0 } then {
  333.         set lineList [lreplace $lineList 0 0 ]
  334.     }
  335.     set numLines [llength $lineList]    
  336.     
  337. # For each line trim stuff on left and spaces and stuff on right and splice
  338.  
  339.     set dropFromLeft [expr $spaceOffset+1]
  340.     set text ""
  341.     for { set i 0 } { $i < $numLines } { incr i } {
  342.         set thisLine [lindex $lineList $i]
  343.         set thisLine [string trimright $thisLine $eliminate]
  344.         set thisLine [string range $thisLine $dropFromLeft end]
  345.         set text $text$thisLine\r
  346.     }
  347.         
  348. # Now replace the old stuff, convert spaces back to tabs
  349.  
  350.     replaceText    $start $end    $text
  351.     set end [expr {$start+[string    length $text]}]
  352.     createTMark stopComment [expr $end+1]
  353.     select $start $end
  354.     spacesToTabs
  355.     gotoTMark stopComment
  356.     set end [expr [getPos]-1]
  357.     removeTMark stopComment
  358.     select $start $end
  359. }
  360.  
  361.  
  362. #================================================================================
  363.  
  364. proc transposeWords {} {
  365.     global intelCutPaste
  366.     
  367.     set intel $intelCutPaste
  368.     set intelCutPaste 0
  369.     forwardWord
  370.     setMark
  371.     backwardWord
  372.     cut
  373.     deleteChar
  374.     forwardWord
  375.     insertText "\ "
  376.     paste
  377.     set intelCutPaste $intel
  378. }
  379.  
  380. proc transposeChars {} {
  381.      global intelCutPaste
  382.     
  383.     set intel $intelCutPaste
  384.     set intelCutPaste 0
  385.     setMark
  386.     forwardChar
  387.     cut
  388.     backwardChar
  389.     paste
  390.     forwardChar
  391.     set intelCutPaste $intel
  392. }
  393.  
  394. proc nextFunc {} {
  395.     searchFunc 1
  396. }
  397.  
  398. proc prevFunc {} {
  399.     searchFunc 0
  400. }
  401.  
  402. proc searchFunc {dir} {
  403.     global funcExpr
  404.     set pos [getPos]
  405.     select $pos
  406.     if ($dir==1) {
  407.         incr pos
  408.     } else {
  409.         set pos [expr $pos-1]
  410.     }
  411.     if {![catch {search -f $dir -i 1 -r 1 $funcExpr $pos} res]} {
  412.         eval select $res
  413.     }
  414. }
  415.  
  416. #===========================================================================
  417. # Comment routines.
  418. #===========================================================================
  419. proc commentPara {} {
  420. }
  421.  
  422.  
  423.  
  424. #===========================================================================
  425. # Sorting the selection.
  426. # AUTHOR: David C. Black     black@mpd.tandem.com
  427. #===========================================================================
  428. proc sortLines {} {
  429.     set ends [getEndpts]
  430.     set start [lindex $ends 0]
  431.     set end  [lindex $ends 1]
  432.     if {$start == $end} {
  433.         alertnote "You must highlight the section you wish to sort."
  434.         return
  435.     }
  436.     if {[lookAt [expr $end-1]] != "\r"} {
  437.         alertnote "The selection must consist only of complete lines."
  438.         return
  439.     }
  440.     set text [getText $start [expr {$end-1}]]
  441.     set text [join [lsort [split $text "\r"]] "\r"]
  442.     replaceText $start [expr {$end-1}] $text
  443.     select $start $end
  444. }
  445.  
  446.  
  447.  
  448. proc compareWindows {} {
  449.     set one [listpick [lsort [winNames -f]]]
  450.     set two [listpick [lsort [winNames -f]]]
  451.     compare-windows $one $two
  452. }
  453.  
  454.  
  455. #===========================================================================
  456. # Dump all current settings into a file.
  457. #===========================================================================
  458. proc insertGlobalSettings {} {
  459.     uplevel #0 {
  460.         foreach var [info globals] {
  461.             if {![catch {set $var}]} {
  462.                 insertText "set " $var " \{" [set $var] "\}\r"
  463.             }
  464.         }
  465.     }
  466. }
  467.  
  468.  
  469. #================================================================================
  470. # Substitute global variables in possibly nested list.
  471. #================================================================================
  472. proc subVars {words} {
  473.     global silly
  474.     global a
  475.     set silly $words
  476.     set out {}
  477.     foreach a $words {
  478.         if {[llength $a] == 1} {
  479.             lappend out [uplevel #0 {eval set x $a}]
  480.         } else {
  481.             lappend out [subVars $a]
  482.         }
  483.     }
  484.     return $out
  485. }
  486.  
  487. #================================================================================
  488. # Block shift left and right.
  489. #================================================================================
  490. set shiftChar    "\t"
  491.  
  492. proc shiftLeft {} {
  493.     global shiftChar
  494.     
  495.      set start [lineStart [getPos]]
  496.      set end [nextLineStart [expr [selEnd] - 1]]
  497.     if {$start >= $end} {set end [nextLineStart $start]}
  498.     
  499.     set text [split [getText $start [expr $end - 1]] "\r"]
  500.     
  501.     set textout ""
  502.     
  503.     foreach line $text {
  504.         if {[string index $line 0] == $shiftChar} {
  505.             lappend textout [string range $line 1 end]
  506.         } else {
  507.             lappend textout $line
  508.         }
  509.     }
  510.  
  511.     set text [join $textout "\r"]    
  512.     replaceText $start [expr $end - 1] $text
  513.     select $start [expr 1 + $start + [string length $text]]
  514. }
  515.  
  516.  
  517. proc shiftRight {} {
  518.     global    shiftChar
  519.     
  520.     set start [lineStart [getPos]]
  521.     set end [nextLineStart [expr [selEnd] - 1]]
  522.     if {$start >= $end} {set end [nextLineStart $start]}
  523.     
  524.     set text [split [getText $start [expr $end - 1]] "\r"]
  525.     
  526.     set textout ""
  527.     
  528.     foreach line $text {
  529.         lappend textout $shiftChar$line
  530.     }
  531.     
  532.     set text [join $textout "\r"]    
  533.     replaceText $start [expr $end - 1] $text
  534.     select $start [expr 1 + $start + [string length $text]]
  535. }
  536.  
  537.  
  538.  
  539. # rglob [option list] dir pat
  540. # 'dir' should be a properly formed directory, ending w/ a ':'. 'pat' should be 
  541. # a simple pattern w/ no directory specifications (i.e. "*.c").
  542. proc rglob {optlist dir pat} {
  543.  
  544.     set cmd [concat glob $optlist]
  545.     lappend cmd $dir$pat
  546.     if {[catch {eval $cmd} files]} {
  547.         set files ""
  548.     }
  549.     
  550.     if {![catch {glob $dir*} all]} {
  551.         foreach f $all {
  552.             if {[file isdir $f]} {
  553.                 set files [concat $files [rglob $optlist $f: $pat]]
  554.             }
  555.         }
  556.     }
  557.     return $files
  558. }
  559.  
  560.  
  561. proc switchApp {} {
  562.     set procs ""
  563.     foreach p [processes] {
  564.         lappend procs [lindex $p 0]
  565.     }
  566.     set to [listpick -p "Switch to app:" $procs]
  567.     if {[string length $to]} {
  568.         switchTo $to
  569.     }
  570. }
  571.  
  572.  
  573. proc selectAll {} {
  574.     select 0 [maxPos]
  575. }
  576.  
  577.  
  578.